C----------------------------------------------------------------------------

C Module name: TopDraw

C Author: Toby Howard

C Function: Implements the PHIGS structure network topology drawing tool.

C External function list: ptk_topology.

C Internal function list:

C Hashtables used: "structureid", "name", "label".

C Modification history: (Version), (Date), (Name), (Description).

C 1.0, ????, Toby Howard, First version.
 
C 1.1, 29th July 1988, Steve Larkin, Modified to use Vax Phigs instead of 
C KRT3.

C 2.0, 10th June 1991, Gareth Williams, Translated to C.

C----------------------------------------------------------------------------

       SUBROUTINE ptkf_createtopology(topid, root, error)
C /* 
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{root}{structure network identifier}{IN}
C ** \param{INTEGER}{error}{error code}{OUT}
C ** \paramend
C ** \blurb{This function creates a diagram of the structure network
C ** specified by {\tt root}. The diagram is a PHIGS structure which
C ** uses boxes connected by lines to represent structures and
C ** EXECUTE STRUCTURE elements. The error code = 1 if the root structure
C ** does not exist.} 
C */
       INTEGER topid, root, error
       external ptk_createtopology !$PRAGMA C(ptk_createtopology)

       call ptk_createtopology(%val(topid), %val(root), error)

       RETURN
       END

       SUBROUTINE ptkf_settopologyattrs(topid, txfont, linecol, 
& textcol, edgecol, intcol, htedgecol, htintcol)
C /* 
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{txfont}{label text font}{IN}
C ** \param{INTEGER}{linecol}{polyline colour index}{IN}
C ** \param{INTEGER}{textcol}{text colour index}{IN}
C ** \param{INTEGER}{edgecol}{edge colour index}{IN}
C ** \param{INTEGER}{intcol}{interior colour index}{IN}
C ** \param{INTEGER}{htedgecol}{highlight edge colour index}{IN}
C ** \param{INTEGER}{htintcol}{highlight interior colour index}{IN}
C ** \paramend
C ** \blurb{This function sets the text font and colour attribute values 
C ** of a topology diagram. The text font applies to the structure
C ** names which are extracted from the \"structureid\" hashtable.
C ** The highlight colour indicies are used to highlight a single
C ** topology node in the function {\tt ptk\_settopologyhighlightnode}.}
C */
       INTEGER topid, txfont, linecol
       INTEGER textcol, edgecol, intcol, htedgecol, htintcol
       external ptk_settopologyattrs !$PRAGMA C(ptk_settopologyattrs)

       call ptk_settopologyattrs(%val(topid), %val(txfont), 
& %val(linecol), %val(textcol), %val(edgecol), %val(intcol), 
& %val(htedgecol), %val(htintcol))

       RETURN
       END

       SUBROUTINE ptkf_inqtopologyattrs(topid, txfont, linecol, 
& textcol, edgecol, intcol, htedgecol, htintcol, err)
C /* 
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{txfont}{label text font}{OUT}
C ** \param{INTEGER}{linecol}{polyline colour index}{OUT}
C ** \param{INTEGER}{textcol}{text colour index}{OUT}
C ** \param{INTEGER}{edgecol}{edge colour index}{OUT}
C ** \param{INTEGER}{intcol}{interior colour index}{OUT}
C ** \param{INTEGER}{htedgecol}{highlight edge colour index}{OUT}
C ** \param{INTEGER}{htintcol}{highlight interior colour index}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the text font and
C ** colour attribute values of a topology diagram.}
C */
       INTEGER topid, txfont, linecol
       INTEGER textcol, edgecol, intcol, htedgecol, htintcol, err
       external ptk_inqtopologyattrs !$PRAGMA C(ptk_inqtopologyattrs)

       call ptk_inqtopologyattrs(%val(topid), txfont, linecol, 
& textcol, edgecol, intcol, htedgecol, htintcol, err)

       RETURN
       END

       SUBROUTINE ptkf_settopologytype(topid, toptype)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{toptype}{topology type}{IN}
C ** \paramend
C ** \blurb{This function sets the type of a topology diagram to 
C ** BOX, STRUCT or STRUCTNET. The BOX topology type is the default and
C ** the STRUCT and STRUCTNET types insert parts of the actual structures
C ** into the nodes. As a result these topology types do not work well
C ** for networks containing SET VIEW INDEX and SET GLOBAL TRANSFORMATION
C ** elements.}
C */
       INTEGER topid, toptype
       external ptk_settopologytype !$PRAGMA C(ptk_settopologytype)

       call ptk_settopologytype(%val(topid), %val(toptype))

       RETURN
       END

       SUBROUTINE ptkf_inqtopologytype(topid, toptype, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{toptype}{topology type}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the type of a topology
C ** diagram. The possible types are BOX, STRUCT and STRUCTNET, with BOX
C ** as the default.}
C */
       INTEGER topid, toptype, err
       external ptk_inqtopologytype !$PRAGMA C(ptk_inqtopologytype)

       call ptk_inqtopologytype(%val(topid), toptype, err)

       RETURN
       END

       SUBROUTINE ptkf_setnodeposition(topid, structid, nodept, 
& nodetype)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \param{REAL}{nodept(2)}{node position}{IN}
C ** \param{INTEGER}{nodetype}{type of node}{IN}
C ** \paramend
C ** \blurb{This function sets the position of a topology node or group
C ** of nodes. The position is given in the range [0, 1].
C ** The node is specified using the structure identifier of the structure
C ** that it represents. If nodetype is set to GROUP then all descendent
C ** nodes of {\tt structid} are moved relative to it.}
C */
       INTEGER topid, structid
       REAL nodept(3)
       INTEGER nodetype
       external ptk_setnodeposition !$PRAGMA C(ptk_setnodeposition)

       call ptk_setnodeposition(%val(topid), %val(structid), 
& nodept, %val(nodetype))

       RETURN
       END

       SUBROUTINE ptkf_inqnodeposition(topid, structid, nodept, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{structid}{structure identifier}{IN}
C ** \param{REAL}{nodept(2)}{node position}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the position of a topology 
C ** node in a topology diagram. The position is returned in the 
C ** range [0, 1]. The node is specified using the structure
C ** identifier of the structure that it represents.}
C */
       INTEGER topid, structid
       REAL nodept(3)
       INTEGER err
       external ptk_inqnodeposition !$PRAGMA C(ptk_inqnodeposition)

       call ptk_inqnodeposition(%val(topid), %val(structid), 
& nodept, err)

       RETURN
       END

       SUBROUTINE ptkf_tidytopology(wsid, topid, nodetype, pickdev, 
& pickpet, pldr, pdatrec, locdev, locpet, lldr, ldatrec)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{nodetype}{type of node}{IN}
C ** \param{INTEGER}{pickdev}{pick device}{IN}
C ** \param{INTEGER}{pickpet}{pick prompt/echo type}{IN}
C ** \param{INTEGER}{pldr}{size of record array}{IN}
C ** \param{CHARACTER*80}{pdatarec(*)}{pick data record}{IN}
C ** \param{INTEGER}{locdev}{locator device}{IN}
C ** \param{INTEGER}{locpet}{locator prompt/echo type}{IN}
C ** \param{INTEGER}{lldr}{size of record array}{IN}
C ** \param{CHARACTER*80}{locdatarec(*)}{locator data record}{IN}
C ** \paramend
C ** \blurb{This function enables the user to set the position of
C ** a topology node, or group of nodes, interactively. The pick device
C ** {\tt pickdev} is used to request a topology node and if
C ** successful the locator device {\tt locdev} is used to specify
C ** a new node position. Prompt and echo types may be set for both
C ** the pick and locator devices.}
C */
       INTEGER wsid, topid, nodetype, pickdev, pickpet, pldr
       CHARACTER*80 pdatrec(pldr)
       INTEGER locdev, locpet, lldr
       CHARACTER*80 ldatrec(lldr)
       INTEGER nodeid
       REAL point(3)
       INTEGER incl(10), excl(10)
       INTEGER i, err
       LOGICAL found
       REAL echo(6)
       REAL maxdevx, maxdevy, maxdevz
       INTEGER topname, topstid
       INTEGER pp(3, 10), ppath(3, 10)
       INTEGER stat, ppd

       include './sunphigs77.h'
       include './sunptk77.h'

       implicit undefined (P, p, E, e)

       call ptkf_inqtopologyname(topid, topname, err)

       call ptkf_inqtopologystructid(topid, topstid, err)
       call ptkf_inqmaxdevicecoords3(wsid, maxdevx, maxdevy, maxdevz)
       call ptkf_limit3(0.0, maxdevx, 0.0, maxdevy, 0.0, maxdevz, echo)

C  pick topology node 
   
       call pspkm(wsid, pickdev, PREQU, PECHO)
       call pinpk3(wsid, pickdev, PNPICK, 0, pp, pickpet, echo, 
& pldr, pdatrec, PPOBOT) 

       incl(1) = topname
       call pspkft(wsid, pickdev, 1, incl, 0, excl)

       call prqpk(wsid, pickdev, 10, stat, ppd, ppath)

       if (stat .ne. POK) then
         RETURN
       endif

C  find picked node 
       i = 0
       found = .FALSE.
 10    if (found .ne. .TRUE. .and. i .lt. 10) then 
         if (ppath(1, i) .eq. topstid) then
           nodeid = ppath(2, i)
           found = .TRUE.
           goto 20
         endif
         i = i + 1
         goto 10
       endif

C  locate point
 20    call pinlc3(wsid, locdev, 0, 0.5, 0.5, 0.0, locpet, echo,
& lldr, ldatrec)
       call pslcm(wsid, locdev, PREQU, PECHO)
       call prqlc3(wsid, locdev, stat, view, point(1), point(2), 
& point(3))

       if (stat .ne. POK) then
         RETURN
       endif
       
       call ptkf_setnodeposition(topid, nodeid, point, nodetype)

       RETURN
       END

       SUBROUTINE ptkf_posttopology(wsid, topid, priority)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{REAL}{priority}{display priority}{IN}
C ** \paramend
C ** \blurb{This function posts a topology diagram structure to the
C ** workstation {\tt wsid}.}
C */ 
       INTEGER wsid, topid
       REAL priority
       REAL*8 dppriority
       external ptk_posttopology !$PRAGMA C(ptk_posttopology)

       dppriority = priority
       call ptk_posttopology(%val(wsid), %val(topid), %val(dppriority))

       RETURN
       END

       SUBROUTINE ptkf_unposttopology(wsid, topid)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \paramend
C ** \blurb{This function unposts the topology diagram structure from
C ** the workstation {\tt wsid}.}
C */
       INTEGER wsid, topid
       external ptk_unposttopology !$PRAGMA C(ptk_unposttopology)

       call ptk_unposttopology(%val(wsid), %val(topid))

       RETURN
       END

       LOGICAL FUNCTION ptkf_deltopology(topid)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \paramend
C ** \blurb{This function deletes a topology diagram from the PHIGS Toolkit
C ** topology store. The function returns TRUE if a topology is deleted, 
C ** otherwise FALSE.}
C */
       INTEGER topid
       LOGICAL*1 ptk_deltopology, ans
       external ptk_deltopology !$PRAGMA C(ptk_deltopology)

       ans = ptk_deltopology(%val(topid))
       if (ans .eq. 1) then
          ptkf_deltopology = .TRUE.
       else
          ptkf_deltopology = .FALSE.
       endif

       RETURN
       END

       SUBROUTINE ptkf_storetopologylayout(fileptr, topid)
C /*
C ** \parambegin
C ** \param{INTEGER}{fileptr}{pointer to file}{OUT}
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \paramend
C ** \blurb{This function saves a topology layout in a text file. The
C ** layout refers to the positions of all the topology nodes. The
C ** format of the stored layout is:
C ** 
C ** {\tt start}
C ** {\tt (for each node in topology diagram)}
C ** {\tt x y}
C ** {\tt end}
C ** }
C */
       INTEGER fileptr, topid
       external ptk_storetopologylayout 
& !$PRAGMA C(ptk_storetopologylayout)

       call ptk_storetopologylayout(%val(fileptr), %val(topid))

       RETURN
       END

       SUBROUTINE ptkf_restoretopologylayout(fileptr, topid)
C /*
C ** \parambegin
C ** \param{INTEGER}{fileptr}{pointer to file}{OUT}
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \paramend
C ** \blurb{This function reads a topology layout from a text file.
C ** The layout is used to reposition the nodes of the topology
C ** diagram {\tt topid} but will only really make sense if the layout
C ** was stored originally from the same topology.} 
C */
       INTEGER fileptr, topid
       external ptk_restoretopologylayout
& !$PRAGMA C(ptk_restoretopologylayout)

       call ptk_restoretopologylayout(%val(fileptr), %val(topid))

       RETURN
       END

       SUBROUTINE ptkf_inqpostedtopologies(wsid, num, topids, totalnum,
& err)
C /*
C ** \parambegin
C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
C ** \param{INTEGER}{size}{size of buffer}{IN}
C ** \param{INTEGER}{topids(*)}{list of posted topologies}{OUT}
C ** \param{INTEGER}{totalsize}{length of posted topologies list}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain a list of all the
C ** topology diagrams which are posted to the workstation {\tt wsid}.}
C */
       INTEGER wsid, num, topids(num), totalnum, err
       external ptkc_inqpostedtopologies 
& !$PRAGMA C(ptkc_inqpostedtopologies)

       call ptkc_inqpostedtopologies(%val(wsid), %val(num), topids, 
& totalsize, err)

       RETURN
       END

       SUBROUTINE ptkf_inqtopologyids(num, topids, totalnum, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{size}{size of buffer}{IN}
C ** \param{INTEGER}{topids(*)}{list of topology identifiers}{OUT}
C ** \param{INTEGER}{totalsize}{length of topology identifiers list}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain a list of all the topology
C ** diagrams in the PHIGS Toolkit topology store.}
C */
       INTEGER num, topids, totalnum, err
       external ptkc_inqtopologyids !$PRAGMA C(ptkc_inqtopologyids)

       call ptkc_inqtopologyids(%val(num), topids, totalnum, err)

       RETURN
       END

       SUBROUTINE ptkf_inqtopologystructid(topid, topstid, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{topstid}{topology structure identifier}{IN}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the structure identifier 
C ** of the topology diagram {\tt topid}. In the case of the BOX topology
C ** type the diagram is a single PHIGS structure but for STRUCT and
C ** STRUCTNET type diagrams it is a structure network.}
C */
       INTEGER topid, topstid, err
       external ptk_inqtopologystructid
& !$PRAGMA C(ptk_inqtopologystructid)

       call ptk_inqtopologystructid(%val(topid), topstid, err)

       RETURN
       END

       SUBROUTINE ptkf_inqtopologyname(topid, topname, err)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{name}{topology name for nameset filters}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the topology name for use 
C ** in the pick filter. When a topology name is added to the pick filter
C ** only the topology nodes are pickable.}
C */
       INTEGER topid, topname, err
       external ptk_inqtopologyname !$PRAGMA C(ptk_inqtopologyname)

       call ptk_inqtopologyname(%val(topid), topname, err)

       RETURN
       END

       SUBROUTINE ptkf_settopologyhighlightnode(topid, topnodestid)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{topnodestid}{topology node structure identifier}{IN}
C ** \paramend
C ** \blurb{This function highlights a single topology node by
C ** setting the colour attribute values of the edge and interior of
C ** the node box. This function only works for BOX topology types.}
C */
       INTEGER topid, topnodestid
       external ptk_settopologyhighlightnode 
& !$PRAGMA C(ptk_settopologyhighlightnode)

       call ptk_settopologyhighlightnode(%val(topid), %val(topnodestid))

       RETURN
       END

       SUBROUTINE ptkf_inqtopologyhighlightnode(topid, topnodestid,
& err)
C /*
C ** \parambegin
C ** \param{INTEGER}{topid}{topology identifier}{IN}
C ** \param{INTEGER}{topnodestid}{topology node structure identifier}{OUT}
C ** \param{INTEGER}{err}{error indicator}{OUT}
C ** \paramend
C ** \blurb{This function may be used to obtain the structure
C ** identifier of the currently highlighted topology node.}
C */
       INTEGER topid, topnodestid, err
       external ptk_inqtopologyhighlightnode 
& !$PRAGMA C(ptk_inqtopologyhighlightnode)

       call ptk_inqtopologyhighlightnode(%val(topid), topnodestid,
& err)

       RETURN
       END

C end of topo.f
